home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1997 / MacHack 1997.toast / Presentations / Presentations ’93 / Voice Toolkit / Voice Utilities < prev    next >
Encoding:
Text File  |  1992-12-07  |  2.9 KB  |  92 lines  |  [TEXT/CCL2]
  1.  
  2. (in-package "VOICE-TOOLKIT")
  3.  
  4. (defun voice-type-p (item)
  5.   (string-equal "voice" (string (class-name item))
  6.                 :start1 0 :start2 0 :end1 4 :end2 4))
  7.  
  8. (defun voice-class-p (class)
  9.   (cond ((null class) nil)
  10.         ((equal (class-name class) 'standard-object) nil)
  11.         ((voice-type-p class) t)
  12.         (t (some #'voice-class-p (class-direct-superclasses class)))))
  13.  
  14.  
  15. (defun voice-item-p (item)
  16.   "use this function to determine whether an item is of voice type"
  17.   (voice-class-p (class-of item)))
  18.  
  19.  
  20. (defun make-voice-shell (args)
  21.   (insert-as-action (voice-shell-fn (find-action args)) args))
  22.  
  23. (defun find-action (args)
  24.   (cond ((equal (first args)
  25.              ':DIALOG-ITEM-ACTION)
  26.          (second args))
  27.         ((null args) nil)
  28.         (t (find-action (rest args)))))
  29.  
  30. (defun insert-as-action (action listing &optional here)
  31.   (cond (here
  32.          (cons action (rest listing)))
  33.         ((null listing)
  34.          (cons ':DIALOG-ITEM-ACTION 
  35.                (insert-as-action action nil t)))
  36.         ((equal (first listing)
  37.                 ':DIALOG-ITEM-ACTION)
  38.          (cons (first listing)
  39.                (insert-as-action action
  40.                                  (rest listing)
  41.                                  t)))
  42.         (t (cons (first listing)
  43.                  (insert-as-action action
  44.                                    (rest listing))))))
  45.  
  46. (defun voice-shell-fn (initfn)
  47.   #'(lambda (x)
  48.       (if initfn (funcall initfn x))
  49.       (reset-voice)))
  50.  
  51.  
  52. (defun voice-mapvect (vector fn position stop)
  53.   (cond ((equal position stop) nil)
  54.         ((voice-item-p (aref vector position))
  55.          (funcall fn (aref vector position))
  56.          (voice-mapvect vector fn (+ 1 position) stop))
  57.         (t (voice-mapvect vector fn (+ 1 position) stop))))
  58.  
  59. (defun string-to-wordlist (string &optional chars)
  60.   (cond ((null string)
  61.          (if chars
  62.            (list (coerce chars 'string))))
  63.         ((stringp string)
  64.          (string-to-wordlist (coerce string 'list)))
  65.         ((member (first string) '(#\Space #\( #\) #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0)
  66.                  :test #'eq)
  67.          (if chars
  68.            (cons (coerce chars 'string)
  69.                  (string-to-wordlist (rest string) nil))
  70.            (string-to-wordlist (rest string) nil)))
  71.         (t (string-to-wordlist (rest string)
  72.                                (append chars (list (first string)))))))
  73.  
  74. (defun set-diff (set1 set2 &optional result)
  75.   (cond ((null set1) result)
  76.         ((member (first set1) set2 :test #'equal)
  77.          (set-diff (rest set1) set2 result))
  78.         (t (set-diff (rest set1) set2 (cons (first set1) result)))))
  79.  
  80.  
  81. (defun valid (ident)
  82.   "checks whether a specified indication method is valid"
  83.   (cond ((and (numberp ident)
  84.               (<= ident *white-color*)
  85.               (>= ident *black-color*))
  86.          ident)
  87.         ((equal (string-upcase (format nil "~a" ident)) "ITALIC")
  88.          :ITALIC)
  89.         ((equal (string-upcase (format nil "~a" ident)) "BOLD")
  90.          :BOLD)
  91.         (t nil)))
  92.